home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / env.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  16KB  |  407 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Basic environmental stuff.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. #+Lucid
  33. (progn
  34.  
  35. (defun pcl-arglist (function &rest other-args)
  36.   (let ((defn nil))
  37.     (cond ((and (fsc-instance-p function)
  38.                 (generic-function-p function))
  39.            (generic-function-pretty-arglist function))
  40.           ((and (symbolp function)
  41.                 (fboundp function)
  42.                 (setq defn (symbol-function function))
  43.                 (fsc-instance-p defn)
  44.                 (generic-function-p defn))
  45.            (generic-function-pretty-arglist defn))
  46.           (t (apply (original-definition 'sys::arglist)
  47.                     function other-args)))))
  48.  
  49. (redefine-function 'sys::arglist 'pcl-arglist)
  50.  
  51. )
  52.  
  53.  
  54. ;;;
  55. ;;;
  56. ;;;
  57.  
  58. (defgeneric describe-object (object stream))
  59.  
  60. #-Genera
  61. (progn
  62.  
  63. (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
  64.   (let (#+Lispm (*describe-no-complaints* no-complaints))
  65.     #+Lispm (declare (special *describe-no-complaints*))
  66.     (describe-object object *standard-output*)
  67.     (values)))
  68.  
  69. (defmethod describe-object (object stream)
  70.   (let ((*standard-output* stream))
  71.     (funcall-compiled (original-definition 'describe) object)))
  72.  
  73. (redefine-function 'describe 'pcl-describe)
  74.  
  75. )
  76.  
  77. (defmethod describe-object ((object slot-object) stream)
  78.   (format stream "~%~S is an instance of class ~S:" object (class-of object))
  79.   (describe-object-slots object stream))
  80.  
  81. (defmethod describe-object-slots
  82.            ((object slot-object)
  83.             stream
  84.             &key
  85.             (slots-to-inspect (slots-to-inspect (class-of object) object))
  86.             &allow-other-keys)
  87.   "Display the value of all the slots-to-inspect on this object."
  88.   (let* ((max-slot-name-length 0)
  89.          (instance-slotds ())
  90.          (class-slotds ())
  91.          (other-slotds ()))
  92.     (declare (type index max-slot-name-length))
  93.     (flet ((adjust-slot-name-length (name)
  94.              (setq max-slot-name-length
  95.                    (the index
  96.                         (max max-slot-name-length
  97.                              (length (the simple-string
  98.                                           (symbol-name name)))))))
  99.            (describe-slot (name value &optional (allocation () alloc-p))
  100.              (if alloc-p
  101.                  (format stream
  102.                          "~% ~A ~S ~VT  "
  103.                          name allocation (+ max-slot-name-length 7))
  104.                  (format stream
  105.                          "~% ~A~VT  "
  106.                          name max-slot-name-length))
  107.              (prin1 value stream)))
  108.  
  109.       ;; Figure out a good width for the slot-name column.
  110.       (dolist (slotd slots-to-inspect)
  111.         (adjust-slot-name-length (slot-definition-name slotd))
  112.         (case (slot-definition-allocation slotd)
  113.           (:instance (push slotd instance-slotds))
  114.           (:class  (push slotd class-slotds))
  115.           (otherwise (push slotd other-slotds))))
  116.       (setq max-slot-name-length
  117.             (the index (min (the index (+ max-slot-name-length 3)) 30)))
  118.  
  119.       (when instance-slotds
  120.         (format stream "~% The following slots have :INSTANCE allocation:")
  121.         (dolist (slotd (nreverse instance-slotds))
  122.           (describe-slot (slot-definition-name slotd)
  123.                          (slot-value-or-default
  124.                            object (slot-definition-name slotd)))))
  125.  
  126.       (when class-slotds
  127.         (format stream "~% The following slots have :CLASS allocation:")
  128.         (dolist (slotd (nreverse class-slotds))
  129.           (describe-slot (slot-definition-name slotd)
  130.                          (slot-value-or-default
  131.                             object (slot-definition-name slotd)))))
  132.  
  133.       (when other-slotds
  134.         (format stream "~% The following slots have allocation as shown:")
  135.         (dolist (slotd (nreverse other-slotds))
  136.           (describe-slot (slot-definition-name slotd)
  137.                          (slot-value-or-default
  138.                            object (slot-definition-name slotd))
  139.                          (slot-definition-allocation slotd))))
  140.       (values))))
  141.  
  142. (defmethod slots-to-inspect ((class slot-class) (object slot-object))
  143.   (class-slots class))
  144.  
  145. (defvar *describe-generic-functions-as-objects-p* nil)
  146.  
  147. (defmethod describe-object ((fun standard-generic-function) stream)
  148.   (format stream "~A is a generic function.~%" fun)
  149.   (format stream "Its arguments are:~%  ~S~%"
  150.           (generic-function-pretty-arglist fun))
  151.   (if *describe-generic-functions-as-objects-p*
  152.       (describe-object-slots fun stream)
  153.       (progn
  154.         (format stream "Its methods are:")
  155.         (dolist (meth (generic-function-methods fun))
  156.           (format stream "~2%**** ~{~S ~}~:S =>~%"
  157.                   (method-qualifiers meth)
  158.                   (unparse-specializers meth))
  159.           (describe-object meth stream)))))
  160.  
  161. ;;;
  162. ;;;
  163. ;;;
  164. (defvar *describe-classes-as-objects-p* nil)
  165.  
  166. (defmethod describe-object ((class class) stream)
  167.   (flet ((pretty-class (c) (or (class-name c) c)))
  168.     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
  169.       (ft "~&~S is a class, it is an instance of ~S.~%"
  170.           class (pretty-class (class-of class)))
  171.       (let ((name (class-name class)))
  172.         (if name
  173.             (if (eq class (find-class name nil))
  174.                 (ft "Its proper name is ~S.~%" name)
  175.                 (ft "Its name is ~S, but this is not a proper name.~%" name))
  176.             (ft "It has no name (the name is NIL).~%")))
  177.       (ft "The direct superclasses are: ~:S, and the direct~%~
  178.            subclasses are: ~:S.  "
  179.           (mapcar #'pretty-class (class-direct-superclasses class))
  180.           (mapcar #'pretty-class (class-direct-subclasses class)))
  181.       (if (class-finalized-p class)
  182.           (ft "The class precedence list is:~%~S~%"
  183.               (mapcar #'pretty-class (class-precedence-list class)))
  184.           (ft "The class is not finalized.~%"))
  185.       (ft "There are ~D methods specialized for this class."
  186.           (length (the list (specializer-direct-methods class))))))
  187.   (when *describe-classes-as-objects-p*
  188.     (describe-object-slots class stream)))
  189.  
  190.  
  191. (declaim (ftype (function (T &optional T) (values T T symbol))
  192.         parse-method-or-spec))
  193. (defun parse-method-or-spec (spec &optional (errorp t))
  194.   (declare (values generic-function method method-name))
  195.   (let (gf method name temp)
  196.     (if (method-p spec) 
  197.         (setq method spec
  198.               gf (method-generic-function method)
  199.               temp (and gf (generic-function-name gf))
  200.               name (if temp
  201.                        (intern-function-name
  202.                          (make-method-spec temp
  203.                                            (method-qualifiers method)
  204.                                            (unparse-specializers
  205.                                              (method-specializers method))))
  206.                        (make-symbol (format nil "~S" method))))
  207.         (m